home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 2.iso / dist / fw_guile.idb / usr / freeware / share / guile / 1.4 / ice-9 / calling.scm.z / calling.scm
Text File  |  2002-07-08  |  11KB  |  323 lines
  1. ;;;; calling.scm --- Calling Conventions
  2. ;;;;
  3. ;;;;     Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
  4. ;;;; 
  5. ;;;; This program is free software; you can redistribute it and/or modify
  6. ;;;; it under the terms of the GNU General Public License as published by
  7. ;;;; the Free Software Foundation; either version 2, or (at your option)
  8. ;;;; any later version.
  9. ;;;; 
  10. ;;;; This program is distributed in the hope that it will be useful,
  11. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13. ;;;; GNU General Public License for more details.
  14. ;;;; 
  15. ;;;; You should have received a copy of the GNU General Public License
  16. ;;;; along with this software; see the file COPYING.  If not, write to
  17. ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  18. ;;;; Boston, MA 02111-1307 USA
  19. ;;;; 
  20.  
  21. (define-module (ice-9 calling))
  22.  
  23. ;;;;
  24. ;;;
  25. ;;; This file contains a number of macros that support 
  26. ;;; common calling conventions.
  27.  
  28. ;;;
  29. ;;; with-excursion-function <vars> proc
  30. ;;;  <vars> is an unevaluated list of names that are bound in the caller.
  31. ;;;  proc is a procedure, called:
  32. ;;;         (proc excursion)
  33. ;;;
  34. ;;;  excursion is a procedure isolates all changes to <vars>
  35. ;;;  in the dynamic scope of the call to proc.  In other words,
  36. ;;;  the values of <vars> are saved when proc is entered, and when
  37. ;;;  proc returns, those values are restored.   Values are also restored
  38. ;;;  entering and leaving the call to proc non-locally, such as using
  39. ;;;  call-with-current-continuation, error, or throw.
  40. ;;;
  41. (defmacro-public with-excursion-function (vars proc)
  42.   `(,proc ,(excursion-function-syntax vars)))
  43.  
  44.  
  45.  
  46. ;;; with-getter-and-setter <vars> proc
  47. ;;;  <vars> is an unevaluated list of names that are bound in the caller.
  48. ;;;  proc is a procedure, called:
  49. ;;;    (proc getter setter)
  50. ;;; 
  51. ;;;  getter and setter are procedures used to access
  52. ;;;  or modify <vars>.
  53. ;;; 
  54. ;;;  setter, called with keywords arguments, modifies the named
  55. ;;;  values.   If "foo" and "bar" are among <vars>, then:
  56. ;;; 
  57. ;;;    (setter :foo 1 :bar 2)
  58. ;;;    == (set! foo 1 bar 2)
  59. ;;; 
  60. ;;;  getter, called with just keywords, returns
  61. ;;;  a list of the corresponding values.  For example,
  62. ;;;  if "foo" and "bar" are among the <vars>, then
  63. ;;; 
  64. ;;;    (getter :foo :bar)
  65. ;;;    => (<value-of-foo> <value-of-bar>)
  66. ;;; 
  67. ;;;  getter, called with no arguments, returns a list of all accepted 
  68. ;;;  keywords and the corresponding values.  If "foo" and "bar" are
  69. ;;;  the *only* <vars>, then:
  70. ;;; 
  71. ;;;    (getter)
  72. ;;;    => (:foo <value-of-bar> :bar <value-of-foo>)
  73. ;;; 
  74. ;;;  The unusual calling sequence of a getter supports too handy
  75. ;;;  idioms:
  76. ;;; 
  77. ;;;    (apply setter (getter))        ;; save and restore
  78. ;;; 
  79. ;;;    (apply-to-args (getter :foo :bar)        ;; fetch and bind
  80. ;;;            (lambda (foo bar) ....))
  81. ;;; 
  82. ;;;     ;; [ "apply-to-args" is just like two-argument "apply" except that it 
  83. ;;;    ;;   takes its arguments in a different order.
  84. ;;; 
  85. ;;;
  86. (defmacro-public with-getter-and-setter (vars proc)
  87.   `(,proc ,@ (getter-and-setter-syntax vars)))
  88.  
  89. ;;; with-getter vars proc
  90. ;;;   A short-hand for a call to with-getter-and-setter.
  91. ;;;   The procedure is called:
  92. ;;;        (proc getter)
  93. ;;;
  94. (defmacro-public with-getter (vars proc)
  95.   `(,proc ,(car (getter-and-setter-syntax vars))))
  96.  
  97.  
  98. ;;; with-delegating-getter-and-setter <vars> get-delegate set-delegate proc
  99. ;;;   Compose getters and setters.
  100. ;;; 
  101. ;;;   <vars> is an unevaluated list of names that are bound in the caller.
  102. ;;;   
  103. ;;;   get-delegate is called by the new getter to extend the set of 
  104. ;;;    gettable variables beyond just <vars>
  105. ;;;   set-delegate is called by the new setter to extend the set of 
  106. ;;;    gettable variables beyond just <vars>
  107. ;;;
  108. ;;;   proc is a procedure that is called
  109. ;;;        (proc getter setter)
  110. ;;;
  111. (defmacro-public with-delegating-getter-and-setter (vars get-delegate set-delegate proc)
  112.   `(,proc ,@ (delegating-getter-and-setter-syntax vars get-delegate set-delegate)))
  113.  
  114.  
  115. ;;; with-excursion-getter-and-setter <vars> proc
  116. ;;;   <vars> is an unevaluated list of names that are bound in the caller.
  117. ;;;   proc is called:
  118. ;;;
  119. ;;;        (proc excursion getter setter)
  120. ;;;
  121. ;;;   See also:
  122. ;;;    with-getter-and-setter
  123. ;;;    with-excursion-function
  124. ;;;
  125. (defmacro-public with-excursion-getter-and-setter (vars proc)
  126.   `(,proc  ,(excursion-function-syntax vars)
  127.       ,@ (getter-and-setter-syntax vars)))
  128.  
  129.  
  130. (define (excursion-function-syntax vars)
  131.   (let ((saved-value-names (map gensym vars))
  132.     (tmp-var-name (gensym 'temp))
  133.     (swap-fn-name (gensym 'swap))
  134.     (thunk-name (gensym 'thunk)))
  135.     `(lambda (,thunk-name)
  136.        (letrec ((,tmp-var-name #f)
  137.         (,swap-fn-name
  138.          (lambda () ,@ (map (lambda (n sn) 
  139.                       `(begin (set! ,tmp-var-name ,n)
  140.                           (set! ,n ,sn)
  141.                           (set! ,sn ,tmp-var-name)))
  142.                     vars saved-value-names)))
  143.         ,@ (map (lambda (sn n) `(,sn ,n)) saved-value-names vars))
  144.      (dynamic-wind
  145.       ,swap-fn-name
  146.       ,thunk-name
  147.       ,swap-fn-name)))))
  148.  
  149.  
  150. (define (getter-and-setter-syntax vars)
  151.   (let ((args-name (gensym 'args))
  152.     (an-arg-name (gensym 'an-arg))
  153.     (new-val-name (gensym 'new-value))
  154.     (loop-name (gensym 'loop))
  155.     (kws (map symbol->keyword vars)))
  156.     (list `(lambda ,args-name
  157.          (let ,loop-name ((,args-name ,args-name))
  158.           (if (null? ,args-name)
  159.               ,(if (null? kws)
  160.                ''()
  161.                `(let ((all-vals (,loop-name ',kws)))
  162.                   (let ,loop-name ((vals all-vals)
  163.                            (kws ',kws))
  164.                    (if (null? vals)
  165.                        '()
  166.                        `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws)))))))
  167.               (map (lambda (,an-arg-name)
  168.                  (case ,an-arg-name
  169.                    ,@ (append
  170.                    (map (lambda (kw v) `((,kw) ,v)) kws vars)
  171.                    `((else (throw 'bad-get-option ,an-arg-name))))))
  172.                ,args-name))))
  173.  
  174.       `(lambda ,args-name
  175.          (let ,loop-name ((,args-name ,args-name))
  176.           (or (null? ,args-name)
  177.               (null? (cdr ,args-name))
  178.               (let ((,an-arg-name (car ,args-name))
  179.                 (,new-val-name (cadr ,args-name)))
  180.             (case ,an-arg-name
  181.               ,@ (append
  182.                   (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars)
  183.                   `((else (throw 'bad-set-option ,an-arg-name)))))
  184.             (,loop-name (cddr ,args-name)))))))))
  185.  
  186. (define (delegating-getter-and-setter-syntax  vars get-delegate set-delegate)
  187.   (let ((args-name (gensym 'args))
  188.     (an-arg-name (gensym 'an-arg))
  189.     (new-val-name (gensym 'new-value))
  190.     (loop-name (gensym 'loop))
  191.     (kws (map symbol->keyword vars)))
  192.     (list `(lambda ,args-name
  193.          (let ,loop-name ((,args-name ,args-name))
  194.           (if (null? ,args-name)
  195.               (append!
  196.                ,(if (null? kws)
  197.                 ''()
  198.                 `(let ((all-vals (,loop-name ',kws)))
  199.                    (let ,loop-name ((vals all-vals)
  200.                         (kws ',kws))
  201.                     (if (null? vals)
  202.                     '()
  203.                     `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws)))))))
  204.                (,get-delegate))
  205.               (map (lambda (,an-arg-name)
  206.                  (case ,an-arg-name
  207.                    ,@ (append
  208.                    (map (lambda (kw v) `((,kw) ,v)) kws vars)
  209.                    `((else (car (,get-delegate ,an-arg-name)))))))
  210.                ,args-name))))
  211.  
  212.       `(lambda ,args-name
  213.          (let ,loop-name ((,args-name ,args-name))
  214.           (or (null? ,args-name)
  215.               (null? (cdr ,args-name))
  216.               (let ((,an-arg-name (car ,args-name))
  217.                 (,new-val-name (cadr ,args-name)))
  218.             (case ,an-arg-name
  219.               ,@ (append
  220.                   (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars)
  221.                   `((else  (,set-delegate ,an-arg-name ,new-val-name)))))
  222.             (,loop-name (cddr ,args-name)))))))))
  223.  
  224.  
  225.  
  226.  
  227. ;;; with-configuration-getter-and-setter <vars-etc> proc
  228. ;;;
  229. ;;;  Create a getter and setter that can trigger arbitrary computation.
  230. ;;;
  231. ;;;  <vars-etc> is a list of variable specifiers, explained below.
  232. ;;;  proc is called:
  233. ;;;
  234. ;;;        (proc getter setter)
  235. ;;;
  236. ;;;   Each element of the <vars-etc> list is of the form:
  237. ;;;
  238. ;;;    (<var> getter-hook setter-hook)
  239. ;;;
  240. ;;;   Both hook elements are evaluated; the variable name is not.
  241. ;;;   Either hook may be #f or procedure.
  242. ;;;
  243. ;;;   A getter hook is a thunk that returns a value for the corresponding
  244. ;;;   variable.   If omitted (#f is passed), the binding of <var> is
  245. ;;;   returned.
  246. ;;;
  247. ;;;   A setter hook is a procedure of one argument that accepts a new value
  248. ;;;   for the corresponding variable.  If omitted, the binding of <var>
  249. ;;;   is simply set using set!.
  250. ;;;
  251. (defmacro-public with-configuration-getter-and-setter (vars-etc proc)
  252.   `((lambda (simpler-get simpler-set body-proc)
  253.       (with-delegating-getter-and-setter ()
  254.     simpler-get simpler-set body-proc))
  255.  
  256.     (lambda (kw)
  257.       (case kw
  258.     ,@(map (lambda (v) `((,(symbol->keyword (car v)))
  259.                  ,(cond
  260.                    ((cadr v)    => list)
  261.                    (else        `(list ,(car v))))))
  262.            vars-etc)))
  263.  
  264.     (lambda (kw new-val)
  265.       (case kw
  266.     ,@(map (lambda (v) `((,(symbol->keyword (car v)))
  267.                  ,(cond
  268.                    ((caddr v)    => (lambda (proc) `(,proc new-val)))
  269.                    (else        `(set! ,(car v) new-val)))))
  270.            vars-etc)))
  271.  
  272.        ,proc))
  273.  
  274. (defmacro-public with-delegating-configuration-getter-and-setter (vars-etc delegate-get delegate-set proc)
  275.   `((lambda (simpler-get simpler-set body-proc)
  276.       (with-delegating-getter-and-setter ()
  277.     simpler-get simpler-set body-proc))
  278.  
  279.     (lambda (kw)
  280.       (case kw
  281.     ,@(append! (map (lambda (v) `((,(symbol->keyword (car v)))
  282.                       ,(cond
  283.                     ((cadr v)    => list)
  284.                     (else        `(list ,(car v))))))
  285.             vars-etc)
  286.            `((else (,delegate-get kw))))))
  287.  
  288.     (lambda (kw new-val)
  289.       (case kw
  290.     ,@(append! (map (lambda (v) `((,(symbol->keyword (car v)))
  291.                       ,(cond
  292.                     ((caddr v)    => (lambda (proc) `(,proc new-val)))
  293.                     (else        `(set! ,(car v) new-val)))))
  294.             vars-etc)
  295.            `((else (,delegate-set kw new-val))))))
  296.  
  297.     ,proc))
  298.  
  299.  
  300. ;;; let-configuration-getter-and-setter <vars-etc> proc
  301. ;;;
  302. ;;;   This procedure is like with-configuration-getter-and-setter (q.v.)
  303. ;;;   except that each element of <vars-etc> is:
  304. ;;;
  305. ;;;        (<var> initial-value getter-hook setter-hook)
  306. ;;;
  307. ;;;   Unlike with-configuration-getter-and-setter, let-configuration-getter-and-setter
  308. ;;;   introduces bindings for the variables named in <vars-etc>.
  309. ;;;   It is short-hand for:
  310. ;;;
  311. ;;;        (let ((<var1> initial-value-1)
  312. ;;;              (<var2> initial-value-2)
  313. ;;;            ...)
  314. ;;;          (with-configuration-getter-and-setter ((<var1> v1-get v1-set) ...) proc))
  315. ;;;
  316. (defmacro-public let-with-configuration-getter-and-setter (vars-etc proc)
  317.   `(let ,(map (lambda (v) `(,(car v) ,(cadr v))) vars-etc)
  318.      (with-configuration-getter-and-setter ,(map (lambda (v) `(,(car v) ,(caddr v) ,(cadddr v))) vars-etc)
  319.                        ,proc)))
  320.  
  321.  
  322.  
  323.